;;;-*- Mode:LISP; Package:FORMAT; Base:8; Readtable:T -*-
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **

;;; (FQUERY OPTIONS FORMAT-STRING &REST FORMAT-ARGS)
;;; OPTIONS is a PLIST.  Defined indicators are:
;;; :MAKE-COMPLETE boolean.  Send a :MAKE-COMPLETE message to the stream if it understands it.
;;; :TYPE one of :TYI, :READLINE.  How typing is gathered and echoed.
;;; :CHOICES a list of choices.
;;;   A choice is either the symbol :ANY or a list.
;;;   If a list, its car is either a possible return value,
;;;     or a list of a possible return value and how to echo it.
;;;   The remaining things in the list are input items that select that return value.
;;;   For a :READLINE type call, they should be strings.
;;;   For a :TYI type call, they should be characters.
;;;   Example choice: ((:foo "Foo") #\F #\space)
;;; :FRESH-LINE boolean.  Send a FRESH-LINE to the stream initially.
;;; :CONDITION symbol.  Signalled before asking.
;;; :LIST-CHOICES boolean.  After prompting in parentheses.
;;; :BEEP boolean.  Before printing message.
;;; :CLEAR-INPUT boolean.  Before printing message.
;;; :HELP-FUNCTION function.  Called with STREAM, CHOICES and TYPE-FUNCTION as arguments.
;;; :STREAM stream or expression.  Specifies the stream to use.
;;;     If it is a symbol (which is not an io-stream) or a list it is evaluated.
;;;     Default is to use *QUERY-IO*.
;;; :DEFAULT-VALUE <value>. to return if defaulted or timed out.
;;; :TIMEOUT <internval-in-60ths>.

;;; Modified printing of timeout values to use TIME:PRINT-INTERVAL-OR-NEVER,
;;; for more intelligible intervals. -KmC 6/88

(DEFVAR Y-OR-N-P-CHOICES '(((T "Yes.") #/Y #/T #/SP #/HAND-UP)
                           ((NIL "No.") #/N #/RUBOUT #/HAND-DOWN)))
(DEFVAR YES-OR-NO-P-CHOICES '((T "Yes") (NIL "No")))

(DEFVAR FQUERY-FORMAT-STRING)
(DEFVAR FQUERY-FORMAT-ARGS)
(DEFVAR FQUERY-LIST-CHOICES)
(DEFVAR FQUERY-CHOICES)
(DEFVAR FQUERY-HELP-FUNCTION)
(DEFVAR FQUERY-STREAM)
(defvar fquery-default-value)
(defvar fquery-timeout)

(DEFUN FQUERY (OPTIONS FQUERY-FORMAT-STRING &REST FQUERY-FORMAT-ARGS
                                            &AUX MAKE-COMPLETE
                                            TYPE TYPE-FUNCTION
                                            FQUERY-CHOICES
                                            STREAM FQUERY-STREAM
                                            FRESH-LINE
                                            CONDITION
                                            FQUERY-LIST-CHOICES
                                            FQUERY-HELP-FUNCTION
                                            BEEP-P CLEAR-INPUT
                                            HANDLED-P VAL
                                            FQUERY-DEFAULT-VALUE FQUERY-TIMEOUT)
  "Ask a multiple-choice question on *QUERY-IO*.
FQUERY-FORMAT-STRING and FQUERY-FORMAT-ARGS are used to print the question.
Ending the string with /"? /" is often appropriate.
OPTIONS is a PLIST.  Defined indicators are:
:MAKE-COMPLETE boolean.  Send a :MAKE-COMPLETE message to the stream if it understands it.
:TYPE one of :TYI, :READLINE, :MINI-BUFFER-OR-READLINE.
  It says how the answer is gathered and echoed.
:CHOICES a list of choices.
  A choice is either the symbol :ANY or a list.
  If a list, its car is either a possible return value,
    or a list of a possible return value and how to echo it.
  The remaining things in the list are input items that select that return value.
  For a :READLINE type call, they should be strings.
  For a :TYI type call, they should be characters.
  Example choice (for :READLINE): ((:foo /"Foo/") #\F #\space)
:FRESH-LINE boolean.  Send a :FRESH-LINE to the stream initially.
:CONDITION symbol.  Signalled before asking.
:LIST-CHOICES boolean.  If T, a list of choices is printed after the question.
:BEEP boolean.  If T, we beep before printing the message.
:CLEAR-INPUT boolean.  If T, we discard type-ahead before printing the message.
:HELP-FUNCTION specifies a function to be called
  if the user types Help.
  It is called with STREAM, CHOICES and TYPE-FUNCTION as arguments.
:STREAM stream or expression.  Specifies the stream to use.
  If it is a symbol (which is not an io-stream) or a list it is evaluated.
  Default is to use *QUERY-IO*.
:DEFAULT-VALUE value.  Return this if defaulted or timed out.
:TIMEOUT <interval-in-60ths>."
  (SETF (VALUES MAKE-COMPLETE TYPE FQUERY-CHOICES STREAM BEEP-P CLEAR-INPUT
                FRESH-LINE CONDITION FQUERY-LIST-CHOICES FQUERY-HELP-FUNCTION
                FQUERY-DEFAULT-VALUE FQUERY-TIMEOUT)
        (APPLY #'FQUERY-DECODE-OPTIONS OPTIONS))
  (SETQ FQUERY-STREAM (IF STREAM
                          (IF (OR (AND (SYMBOLP STREAM) (NOT (GET STREAM 'SI:IO-STREAM-P)))
                                  (CONSP STREAM))
                              (EVAL STREAM)
                            STREAM)
                        *QUERY-IO*))
  (SETQ TYPE-FUNCTION (OR (GET TYPE 'FQUERY-FUNCTION)
                          (FERROR NIL "~S is not a valid :TYPE for FQUERY" TYPE)))
  (AND CONDITION
       (OR (NEQ CONDITION 'FQUERY)
           (EH:CONDITION-NAME-HANDLED-P CONDITION))
       (MULTIPLE-VALUE (HANDLED-P VAL)
         (SIGNAL-CONDITION
           (APPLY #'MAKE-CONDITION CONDITION OPTIONS FQUERY-FORMAT-STRING FQUERY-FORMAT-ARGS)
           '(:NEW-VALUE))))
  (IF HANDLED-P VAL
;     (UNWIND-PROTECT
        (PROGN
;         (COND ((AND SELECT
;                     (MEMQ :SELECT (SEND FQUERY-STREAM :WHICH-OPERATIONS)))
;                (SEND FQUERY-STREAM :OUTPUT-HOLD-EXCEPTION)
;                (SETQ OLD-SELECTED-WINDOW TV:SELECTED-WINDOW)
;                (SEND FQUERY-STREAM :SELECT)))
          (BLOCK TOP
            (DO-FOREVER
              (AND BEEP-P (SEND FQUERY-STREAM :BEEP 'FQUERY))
              (AND CLEAR-INPUT (SEND FQUERY-STREAM :CLEAR-INPUT))
              (AND FRESH-LINE (SEND FQUERY-STREAM :FRESH-LINE))
              (MULTIPLE-VALUE-BIND (TYPEIN TIMEOUT-P)
                  (FUNCALL TYPE-FUNCTION :READ FQUERY-STREAM)
                (cond (timeout-p
                       (format fquery-stream "~A -- timed out." (find-fquery-default))
                       (AND MAKE-COMPLETE
                            (SEND FQUERY-STREAM :SEND-IF-HANDLES :MAKE-COMPLETE))
                       (RETURN-FROM TOP TYPEIN))
                      (t
                       (DOLIST (CHOICE FQUERY-CHOICES)
                         (COND ((EQ CHOICE :ANY)
                                (FUNCALL TYPE-FUNCTION :ECHO TYPEIN FQUERY-STREAM)
                                (AND MAKE-COMPLETE
                                     (SEND FQUERY-STREAM :SEND-IF-HANDLES :MAKE-COMPLETE))
                                (RETURN-FROM TOP TYPEIN))
                               ((FUNCALL TYPE-FUNCTION :MEMBER TYPEIN (CDR CHOICE))
                                (SETQ CHOICE (CAR CHOICE))
                                (WHEN (CONSP CHOICE)
                                  (FUNCALL TYPE-FUNCTION :ECHO (CADR CHOICE) FQUERY-STREAM)
                                  (SETQ CHOICE (CAR CHOICE)))
                                (AND MAKE-COMPLETE
                                     (SEND FQUERY-STREAM :SEND-IF-HANDLES :MAKE-COMPLETE))
                                (RETURN-FROM TOP CHOICE)))))))
              (SETQ BEEP-P T
                    CLEAR-INPUT T
                    FRESH-LINE T                ;User spazzed, will need fresh line
                    FQUERY-LIST-CHOICES T))))   ;and should list options
;       (AND OLD-SELECTED-WINDOW (SEND OLD-SELECTED-WINDOW :SELECT NIL)))
        ))


(DEFVAR *ALLOW-FQUERY-TIMEOUTS* T
  "T if you want the :TIMEOUT option to be noticed.")

(DEFUN FQUERY-DECODE-OPTIONS (&KEY (MAKE-COMPLETE T)
                                   (TYPE :TYI)
                                   (CHOICES Y-OR-N-P-CHOICES)
                                   STREAM
                                   BEEP
                                   CLEAR-INPUT
                                   (FRESH-LINE T)
                                   (CONDITION 'FQUERY)
                                   SIGNAL-CONDITION
                                   (LIST-CHOICES T)
                                   SELECT     ;no longer used
                                   (HELP-FUNCTION 'DEFAULT-FQUERY-HELP)
                                   DEFAULT-VALUE
                                   TIMEOUT)
  SIGNAL-CONDITION SELECT
  (LET((CHOICES (IF (EQ CHOICES :ANY) '(:ANY) CHOICES)))
    (VALUES MAKE-COMPLETE TYPE CHOICES STREAM BEEP CLEAR-INPUT
            FRESH-LINE CONDITION LIST-CHOICES HELP-FUNCTION
            DEFAULT-VALUE
            (IF *ALLOW-FQUERY-TIMEOUTS* TIMEOUT))))

(defun string-to-handle-any-as-choice (remaining-choices &optional first-p)
  (cond (remaining-choices "anything")
        (first-p "anything")
        (t "anything else")))

(DEFUN FQUERY-PROMPT (STREAM &REST IGNORE)
  (AND FQUERY-FORMAT-STRING
       (APPLY #'FORMAT STREAM FQUERY-FORMAT-STRING FQUERY-FORMAT-ARGS))
  (AND FQUERY-LIST-CHOICES
       (DO ((CHOICES FQUERY-CHOICES (CDR CHOICES))
            (FIRST-P T NIL)
            (MANY (> (LENGTH FQUERY-CHOICES) 2))
            (CHOICE))
           ((NULL CHOICES)
            (OR FIRST-P
                (SEND STREAM :STRING-OUT ") ")))
         (SEND STREAM :STRING-OUT (COND (FIRST-P "(")
                                        ((NOT (NULL (CDR CHOICES))) ", ")
                                        (MANY ", or ")
                                        (T " or ")))
         (IF (EQ (CAR CHOICES) :ANY)
             (SEND STREAM :STRING-OUT
                   (string-to-handle-any-as-choice (cdr choices) first-p))
           (progn
             (SETQ CHOICE (CADAR CHOICES))
; character lossage
             (COND ((TYPEP CHOICE '(OR NUMBER CHARACTER))
                    (FORMAT STREAM "~:@C" CHOICE))
                   ((EQUAL CHOICE "")
                    (PRINC "nothing" STREAM))
                   (T
                    (SEND STREAM :STRING-OUT CHOICE)))))))
  (AND FQUERY-TIMEOUT
                                                ;attempt to print out what will return default-value.
       (DO ((CHOICES FQUERY-CHOICES (CDR CHOICES))
            (choice))
           ((NULL CHOICES)
            (FORMAT STREAM "(Automatic default returns ~s after ~a) "
                    fquery-default-value
                    (time:print-interval-or-never
                      (// fquery-timeout 60.)
                      nil)))
         (setq choice (car choices))
         (cond ((eq choice :any))
               ((equal fquery-default-value
                       (if (consp (car choice))
                           (caar choice)
                         (car choice)))
                (return
                  (format stream "(Automatic default after ~a, ~a) "
                          (time:print-interval-or-never
                            (// fquery-timeout 60.)
                            nil)
                          (cadr choice)))))))
  )

(DEFUN DEFAULT-FQUERY-HELP (STREAM CHOICES TYPE)
  (declare(ignore TYPE))                        ;Not used
  (DO ((CHOICES CHOICES (CDR CHOICES))
       (FIRST-P T NIL)
       (CHOICE))
      ((NULL CHOICES)
       (OR FIRST-P
           (SEND STREAM :STRING-OUT ") ")))
    (SEND STREAM :STRING-OUT (COND (FIRST-P "(Type ")
                                   ((NOT (NULL (CDR CHOICES))) ", ")
                                   (T " or ")))
    (SETQ CHOICE (CAR CHOICES))
    (COND ((EQ CHOICE :ANY)
           (PRINC  (string-to-handle-any-as-choice (cdr choices) first-p) STREAM))
          (T
           ;;Print the first input which selects this choice.
           ;;Don't confuse the user by mentioning possible alternative inputs.
; character lossage
           (COND ((TYPEP (CADR CHOICE) '(OR NUMBER CHARACTER))
                  (FORMAT STREAM "~:@C" (CADR CHOICE)))
                 ((EQUAL (CADR CHOICE) "")
                  (PRINC "nothing" STREAM))
                 (T
                  (SEND STREAM :STRING-OUT (CADR CHOICE))))
           ;; If that would echo as something else, say so
           (IF (CONSP (CAR CHOICE))
               (FORMAT STREAM " (~A)" (CADAR CHOICE)))))))

(defun find-fquery-default ()
  (dolist (element fquery-choices)
    (let ((choice (car element)))
      (when (eq fquery-default-value (if (consp choice) (car choice) choice))
        ;;We found the default that will be returned.  How does it echo?
        (let ((value (if (consp choice) (cadr choice) (cadr element))))
          (return (if (and (stringp value)
                           (char= (char value (1- (string-length value))) #/.))
                      ;;Kludge -- strip off period at end.
                      (substring value 0 (1- (string-length value)))
                    value)))))))

(DEFPROP :TYI TYI-FQUERY-FUNCTION FQUERY-FUNCTION)
(DEFSELECT TYI-FQUERY-FUNCTION
  (:READ (STREAM)
    (labels ((read-it ()
              (DO ((CH)) (NIL)
                (FQUERY-PROMPT STREAM)
                (SETQ CH (READ-CHAR STREAM))
                (cond ((AND (CHAR= CH #/HELP) FQUERY-HELP-FUNCTION)
                       (SEND FQUERY-HELP-FUNCTION STREAM FQUERY-CHOICES 'TYI-FQUERY-FUNCTION)
                       (SEND STREAM :FRESH-LINE))
                      ((char= ch #/clear-screen)
                       (send-if-handles stream :clear-screen))
                      (t
                       (RETURN CH))))))

      (if (null fquery-timeout)
          (read-it)
        (with-timeout (fquery-timeout
                        (values fquery-default-value t))
          (read-it)))))
  (:ECHO (ECHO STREAM)
    (SEND STREAM :STRING-OUT (STRING ECHO)))
  (:MEMBER (CHAR LIST)
; character lossage
    (MEM #'(LAMBDA (X Y) (CHAR-EQUAL X (COERCE Y 'CHARACTER))) CHAR LIST)))

(DEFPROP :READLINE READLINE-FQUERY-FUNCTION FQUERY-FUNCTION)
(DEFSELECT READLINE-FQUERY-FUNCTION
  (:READ (STREAM &AUX STRING)
    (labels ((read-it ()
              (if (operation-handled-p stream :rubout-handler)
                  (SETQ STRING (SEND STREAM :RUBOUT-HANDLER `((:EDITING-COMMAND ,(char-int #/Help)
                                                                                #/HELP)        ;Just in case
                                                              (:PROMPT FQUERY-PROMPT)
                                                              (:DONT-SAVE T))
                                     'FQUERY-READLINE-WITH-HELP STREAM))
                (setq string (send stream :line-in)))
              (STRING-TRIM '(#/SP) STRING)))
      (if (null fquery-timeout)
          (read-it)
        (with-timeout (fquery-timeout
                         (values fquery-default-value t))
          (read-it)))))
  (:ECHO (ECHO STREAM)
    ECHO STREAM)
  (:MEMBER (STRING LIST)
    (MEM #'STRING-EQUAL STRING LIST)))

(DEFUN FQUERY-READLINE-WITH-HELP (STREAM)
  (DO ((STRING (MAKE-STRING 20. :FILL-POINTER 0))
       (CH))
      (NIL)
    (SETQ CH (READ-CHAR STREAM))
    (COND ((OR (NULL CH) (CHAR= CH #/CR))
           (RETURN STRING))
          ((AND (CHAR= CH #/HELP) FQUERY-HELP-FUNCTION)
           (FRESH-LINE STREAM)
           (SEND FQUERY-HELP-FUNCTION STREAM FQUERY-CHOICES 'READLINE-FQUERY-FUNCTION)
           (SEND STREAM :SEND-IF-HANDLES :REFRESH-RUBOUT-HANDLER))
          ((NOT (ZEROP (CHAR-BITS CH))))
          (T (VECTOR-PUSH-EXTEND CH STRING)))))

(PROCLAIM '(SPECIAL ZWEI:*MINI-BUFFER-ARG-DOCUMENTER*))  ;DEFVAR is in ZWEI.

(DEFPROP :MINI-BUFFER-OR-READLINE MINI-BUFFER-OR-READLINE-FQUERY-FUNCTION FQUERY-FUNCTION)
(DEFUN MINI-BUFFER-OR-READLINE-FQUERY-FUNCTION (&REST ARGS &AUX STRING)
  (COND ((AND (EQ (CAR ARGS) :READ)
              (EQ (CADR ARGS) 'ZWEI:*TYPEIN-WINDOW*-SYN-STREAM))
         (LET ((ZWEI:*MINI-BUFFER-ARG-DOCUMENTER* 'MINI-BUFFER-OR-READLINE-HELP-FUNCTION))
           (FUNCALL (CADR ARGS) :SEND-IF-HANDLES :MAKE-COMPLETE)
           (SETQ STRING (APPLY #'ZWEI:TYPEIN-LINE-READLINE
                               FQUERY-FORMAT-STRING FQUERY-FORMAT-ARGS)))
         (STRING-TRIM '(#/SP) STRING))
        (T
         (APPLY #'READLINE-FQUERY-FUNCTION ARGS))))

(DEFUN MINI-BUFFER-OR-READLINE-HELP-FUNCTION ()
  (FORMAT *TERMINAL-IO* "~&~%You are now typing an answer to a query.~&")
  (FUNCALL FQUERY-HELP-FUNCTION *TERMINAL-IO* FQUERY-CHOICES
           'MINI-BUFFER-OR-READLINE-FQUERY-FUNCTION))

(DEFCONST Y-OR-N-P-OPTIONS `(:FRESH-LINE NIL))

(DEFUN Y-OR-N-P (&OPTIONAL FORMAT-STRING &REST FORMAT-ARGS)
  "Ask the user a question he can answer with Y or N.
Passes the arguments to FORMAT.
With no args, asks the question without printing anything but the /"(Y or N)/".
Returns T if the answer was yes."
  (FQUERY Y-OR-N-P-OPTIONS
          (AND FORMAT-STRING
               (> (length format-string) 0)
               (IF (CHAR= (CHAR FORMAT-STRING (max 0 (1- (LENGTH FORMAT-STRING)))) #/SP)
                   "~&~?" "~&~? "))
          FORMAT-STRING
          FORMAT-ARGS))

(DEFUN Y-OR-N-P-WITH-TIMEOUT (&OPTIONAL (TIMEOUT (* 15. 60.)) DEFAULT-VALUE FORMAT-STRING &REST FORMAT-ARGS)
  "Like Y-OR-N-P, but times out and returns DEFAULT-VALUE if
the user has not answered in (// TIMEOUT 60.) seconds."
  (FQUERY `(:timeout ,timeout
            :default-value ,default-value
            ,@Y-OR-N-P-OPTIONS)
          (AND FORMAT-STRING
               (> (length format-string) 0)
               (IF (CHAR= (CHAR FORMAT-STRING (max 0 (1- (LENGTH FORMAT-STRING)))) #/SP)
                   "~&~?" "~&~? "))
          FORMAT-STRING
          FORMAT-ARGS))

(DEFCONST YES-OR-NO-P-OPTIONS `(:FRESH-LINE NIL
                                :BEEP T
                                :TYPE :READLINE
                                :CHOICES ,YES-OR-NO-P-CHOICES))

(DEFUN YES-OR-NO-P (&OPTIONAL FORMAT-STRING &REST FORMAT-ARGS)
  "Ask the user a question he can answer with Yes or No.
Beeps and discards type-ahead.
Passes the arguments to FORMAT.
With no args, asks the question without printing anything but the /"(Yes or No)/".
Returns T if the answer was yes."
  (FQUERY YES-OR-NO-P-OPTIONS
          (AND FORMAT-STRING
               (> (length format-string) 0)
               (IF (CHAR= (CHAR FORMAT-STRING (max 0 (1- (LENGTH FORMAT-STRING)))) #/SP)
                   "~&~?" "~&~? "))
          FORMAT-STRING
          FORMAT-ARGS))

(DEFUN YES-OR-NO-P-WITH-TIMEOUT (&OPTIONAL (TIMEOUT (* 15. 60.)) DEFAULT-VALUE FORMAT-STRING &REST FORMAT-ARGS)
  "Like YES-OR-NO-P, but times out and returns DEFAULT-VALUE if
the user has not answered in (// TIMEOUT 60.) seconds."
  (FQUERY `(:timeout ,timeout
            :default-value ,default-value
            ,@YES-OR-NO-P-OPTIONS)
          (AND FORMAT-STRING
               (> (length format-string) 0)
               (IF (CHAR= (CHAR FORMAT-STRING (max 0 (1- (LENGTH FORMAT-STRING)))) #/SP)
                   "~&~?" "~&~? "))
          FORMAT-STRING
          FORMAT-ARGS))

(DEFCONST YES-OR-NO-QUIETLY-P-OPTIONS `(:TYPE :READLINE
                                        :CHOICES ,YES-OR-NO-P-CHOICES))
